COMPIL(ARY,<LRCOP,ARCOP,LRMAK,ARMAK,ARYEL,BEXIT,STKUWD
ENTINT <ARRINFO,ARRBLT,ARRTRAN,ARRCLR>>
  ,<SAVE,RESTR,CORGET,CORREL,X11,X22,X33,X44,GOGTAB,ARRRCL,RECQQ,LEAP,ALLFOR>
  ,<ARRAY ALLOCATION ROUTINES>)
HERE(LRCOP)
HERE(ARCOP)
	PUSH	P,B
	PUSH	P,C		;SOME WORK SPACE.
	PUSH	P,-3(P)		;ARRAY TO BE COPIED
	PUSHJ	P,..ARCOP	;COPY IT
	POP	P,C
	POP	P,B
	SUB	P,X22
	JRST	@2(P)		;DONE
↑↑..ARCOP:
	HRRZ	A,-1(P)		;THE ARRAY TO BE COPIED.
	SKIPGE	-2(A)
	SUBI	A,1		;FOR STRING ARRAYS.
	HLRE	B,-1(A)		;NUMBER OF DIMENSIONS.
	MOVMS	B		;ABSOLUTE VALUE.
	IMUL	B,[-3]
	ADDI	A,-2(B)		;A NOW POINTS TO "CORGET" GUY.
	MOVN	C,-1(A)		;SIZE
	SUBI	C,3		;TO ACCOUNT FOR BOOKEEPING.
	PUSHJ	P,CORGET
	ERR	<NO ROOM FOR ARRAY>
	PUSH	P,B
	HRLI	B,(A)		;MAKE UP A BLT WORD.
	ADDI	C,(B)
	BLT	B,-1(C)		;COPY THE WHOLE ARRAY.
	POP	P,B		;BECAUSE BLT DESTROYS ITS.
	HRRZS	A		;SINCE THE ADDI ABOVE LEFT STUFF IN LEFT HALF.
	MOVNS	A
	ADDI	A,(B)		;A HAS NEW-OLD DIFFERENCE.
	ADDM	A,(B)		;THESE HAVE TO BE RELOCATED.
	ADD	A,-1(P)		;NEW ARRAY DESCRIPTOR.
	HRRM	A,-2(B)		;FOR STRING GARBAGE COLLECTOR.
	MOVE	C,-1(P)		;ARRAY THAT WAS COPIED.
	SKIPGE	-2(C)		;WAS IT A STRING ARRAY?
	SOS	-2(B)		;BACK IT UP ONCE.
	SUB	P,X22
	JRST	@2(P)		;ALL DONE.
HERE(LRMAK)
HERE (ARMAK)
BEGIN	ARMAK
	PUSHJ	P,SAVE
	HRRZ	A,-1(P)		;#DIMENSIONS
	MOVEI	B,-2(P)		; PTR TO BOUNDS(n)
	MOVEI	C,1
MAKLUP:	SOJL	A,SIZDUN	;DONE GETTING TOTAL SIZE
	MOVE	D,(B)		;UPPER BOUND
	ADDI	D,1		;PLUS ONE.
	SUB	D,-1(B)		;  -LOWER BOUND IS TOTAL SIZE
	SKIPG	D		;MUST BE POSITIVE
	 ERR	 <ARRAY lower bound gtr  upper bound>,1,SIZ0
	IMUL	C,D		;COLLECT SIZE
SIZ0:	SUBI	B,2		;LOOK AT NEXT
	JRST	MAKLUP
SIZDUN:	; MOVEI C,SIZE DESIRED -- ALREADY THERE
	SKIPGE	-1(P)		;IF #DIMS POSITIVE, THEN NOT STRING ARRAY
	LSH	C,1		;MULTIPLY BY TWO FOR STRINGS.
	PUSH	P,C		;SAVE SIZE OF ARRAY ITSELF
	HRRZ	A,-2(P)		;#DIMENSIONS AGAIN
	IMULI	A,3		;SIZE OF ARRAY DESCRIPTOR TABLE
	ADDI	C,2(A)		;ADD TO SIZE OF AREA NEEDED
AGIN:	PUSH	P,C		;SAVE IT
	PUSHJ	P,CORGET		;ARRAY
	 ERR	 <ARRAY no room>
GOTARR:	POP	P,C		;TOTAL SIZE AGAIN
	MOVE	D,B		;SAVE ADDRESS
	HRRZ	TEMP,B
	ADD	TEMP,C
	POP	P,C		;ARRAY SIZE
	PUSH	P,B		;SAVE PTR TO ARRAY BLOCK
	SETZM	(B)
	HRLS	B
	ADDI	B,1
	BLT	B,-1(TEMP)	;CLEAR ARRAY
	HRRZI	B,(D)		;GET ADDRESS BACK
	HRRZ	TEMP,-2(P)	;#DIMENSIONS AGAIN
	SKIPGE	-2(P)		;STRING ARRAY?
	 MOVNS	TEMP		; YES
	HRL	C,TEMP		;#DIMS, TOTAL SIZE (#DIMS NEG IF STRING)
	PUSH	P,C		;SAVE INFORMATION WORD
	ADDI	B,1		;LEAVE ROOM FOR ADDRESS WORD
	HRRZ	A,-3(P)		;#DIMS
	MOVE	LPSA,A		;PREPARE FOR SUBRT RETURN
	LSH	LPSA,1
	ADDI	LPSA,2
	HRLS	LPSA
	MOVEI	D,-4(P)		; PTR TO INFO
	MOVEI	C,1		;MULTIPLY FACTOR
	MOVEI	X,0		;ACCUMULATE TOTAL DISPLACEMENT
STOLUP:	SOJL	A,STODUN
	MOVEW	(<1(B)>,<(D)>) ;UPPER BOUND
	ADDI	TEMP,1
	SUB	TEMP,-1(D)		;TOTAL SIZE
	MOVEM	C,2(B)		;AND MULTIPLY FACTOR
	IMUL	C,TEMP		;TEMP HAS SIZE THIS DIMENSION
	MOVEW	(<(B)>,<-1(D)>)	;STORE LOWER BOUND
	IMUL	TEMP,2(B)	;COLLECT TOTAL DISPLACEMENT
	ADD	X,TEMP		;IN X
	ADDI	B,3
	SUBI	D,2
	JRST	STOLUP		;UPDATE POINTERS AND LOOP
STODUN:	POP	P,(B)		;INFO WORD
	ADDI	B,1		;WILL POINT AT FIRST DATA WORD
	POP	P,TEMP	;PTR TO BLOCK HEAD
	HRRZM	B,-2(TEMP)	;STORE WHERE STRNGC CAN FIND IT
	SKIPGE	-1(B)		;IS IT A STRING ARRAY?
	HRROI	B,1(B)		;YES, POINT AT 2D WORD OF FIRST ELEMENT
	MOVEM	B,RACS+1(USER)	;RESULT
	JUMPGE	B,NSTG		;STRING ARRAY?
	 LSH	 X,1		; YES, DOUBLE DISPLACEMENT
NSTG:	SUB	B,X		;ARRAY ADDR - TOTAL DISPLACEMENT
	HLL	B,RACS+1(USER)	;-1 IF STRING, 0 OTHERWISE
	MOVEM	B,(TEMP)	;SAVE IN (0,0,0) WORD
	JRST	RESTR
BEND ARMAK
HERE(ARYEL)
BEGIN ARYEL
	HRRZ	B,-1(P)
	POP	P,-1(P)		;PUT POPJ ADDRESS BACK FOR CORREL.
	SKIPGE	-2(B)
	SUBI	B,1		;COMPUTE THE HEADER ADDRESS.
	HLRE	A,-1(B)
	MOVMS	A
	IMUL	A,[-3]
	ADDI	B,-2(A)
	HRRZS	B
	JRST	CORREL		;RELEASE IT.
BEND
HERE(BEXIT)
BEGIN BEXIT
BKCNT←5
BKPTR←6
TPTR←7
EN←10	;ALSO USED BY STKUWD
PDA←11	;THIS IS USED BY STKUWD, BUT SOME OF THE LVIDAC ROUTINES MUST SAVE IT
	PUSH	P,A			;SAVE A
	HLRE	BKCNT,LPSA		;SAVE COUNT
	HRRZ	BKPTR,LPSA		;POINT
	MOVE	TPTR,[POINT 4,EN,3]	;BYTE PTR FOR TYPE
NXTEN:	MOVE	EN,(BKPTR)		;PICK ONE UP
	LDB	A,TPTR			;PICK UP TYPE
	PUSHJ	P,@[ ↑↑LVIDAC:	DRYROT
				RARY	;1
				RARY	;2
				SLFRE	;3 -- SET OR LIST
				LAFRE	;LEAP ARRAY OF SETS OR LISTS
				FEVAR	;5 FOR EACH CONTROL VARIABLE
				KLIST	;6  
				CTEXTT	;7 CONTEXT
				CLNUP	;10
				RDREF	;11 RECORD
				DRYROT	;12
				DRYROT	;13
				DRYROT	;14
				DRYROT	;15
				DRYROT	;16
				BKE	;17 END OF BLOCK AREA
				](A)
	AOJA	BKPTR,NXTEN	;GET NEXT
DRYROT: ERR <DRYROT: BEXIT>
	POPJ	P,
RARY:	SKIPN   C,@EN
	POPJ	P,
	EXCH	C,(P)		;CLEVER WAY TO FIX THE STACK FOR CALL TO
	PUSH	P,C
	SETZM	@EN		;SAY IT IS GONE
	JRST	ARYEL		;MAKE IT THE TRUTH
SLFRE:	SKIPN	A,@EN		;
	POPJ	P,
	SETZM	@EN		;ZERO OUT THE DESCRIPTOR
	PUSH	P,5		;SAVE IT
	PUSH	P,6
	MOVEI	5,0		;FOR RECLAIMER
	PUSHJ	P,RECQQ		;SINCE SET
	POP	P,6
	POP	P,5
	POPJ	P,
CTEXTT: SKIPN	A,@EN		;CONTEXT EMPTY?
	POPJ	P,		;YES
	PUSH	P,EN		;CONTEXT ADDRESS
	PUSHJ	P,ALLFOR	;FORGET EVERYTHING
	POPJ	P,
LAFRE:	SKIPN	A,@EN		;ARRAY PTR
	POPJ	P,		;NOBODY HOME
	PUSH	P,A
	SETZM	@EN
	PUSHJ	P,ARRRCL	;JRL'S MAGICAL SET ARRAY ZAPPER
	EXCH	A,(P)		;CLEVER TRICK AGAIN
	PUSH	P,A		;
	JRST	ARYEL		;GIVE UP THE SPACE
BKE:	SOJGE	BKCNT,GETNXT	;DO WE NEED TO DO MORE?
	MOVE	A,-1(P)
	SUB	P,[XWD 3,3]	;
	JRST	@1(P)		;NO
GETNXT:	MOVEI	BKPTR,@EN	;GET LINK
	SOJGE	BKPTR,CPOPJ	;WILL COMPENSATE FOR AOS
	ERR 	<DRYROT: BEXIT>
FEVAR:	SKIPN	A,@EN
CPOPJ:	POPJ	P,
	PUSH	P,PDA
	PUSH	P,BKCNT
	PUSH	P,BKPTR
	PUSH	P,TPTR
	MOVEI	5,47		;CHANGED (11-30-72) TO REFLECT NEW INDICES
	PUSHJ	P,LEAP
	POP	P,TPTR
	POP	P,BKPTR
	POP	P,BKCNT
	POP	P,PDA
	POPJ	P,
KLIST:	SKIPN	A,@EN
	POPJ	P,
	ERR	<UNTERMINATED PROCESS DEPENDS ON A BLOCK BEING EXITED 
MAY CONTINUE >,1
	POPJ	P,
CLNUP:	PUSH	P,PDA
	PUSH	P,BKCNT
	PUSH	P,BKPTR
	PUSH	P,TPTR
	PUSHJ	P,(EN)		;CALL THE PROUCEDURE
	POP	P,TPTR
	POP	P,BKPTR
	POP	P,BKCNT
	POP	P,PDA
	POPJ	P,
REC <
RDREF:	SKIPN	A,@EN		;GONE ALREADY
	POPJ	P,
	SOSLE	-1(A)		;REF COUNT LOSES ONE
	JRST	.+3		;DONE
	AOS	-1(A)		;PUT IT BACK SO NEXT GUY CAN DO SAME
	RECUUO	0,@EN		;DEREFERENCE LIKE SO
	SETZM	@EN		;ZERO OUT
	POPJ	P,		;RETURN
>;REC
NOREC <
RDREF:	JRST	DRYROT
>;NOREC
BEND BEXIT
HERE (STKUWD)
BEGIN	STKUWD
CDLSAV←5
LLFGR←6
SIN←7
EN←10
PDA←11
	MOVE	USER,GOGTAB		
	POP	P,STKURT(USER)		;REMEMBER RETURN ADDRESS
	HRRZM	LPSA,CDLSAV		;
	HLROM	LPSA,LLFGR		;SET UP PARAMETERS FOR USE 
PLOOP:	HLRZ	PDA,1(RF)		;PICK UP PROC DESC ADDRESS
	CAIN	PDA,0			;IS THIS THE BITTER END
	ERR	<GO TO OUT OF A PROCESS WILL NOT WORK> ;YES
	MOVE	SP,2(RF)		;OLD OLD SP
	HLLZ	A,PD.DSW(PDA)		;EXTRA SS DISPL NEED
	HLR	A,A			;BOTH SIDES
	ADD	SP,A			;
	HRRZ	A,PD.DSW(PDA)		;ARITH STK DISPL
	ADDI	A,(RF)			;+RF
	HRRZ	B,P			;WHERE WE ARE NOW
	SUB	B,A			;HOW FAR BACK TO GO
	HRL	B,B			;BOTH SIDES
	SUB	P,B			;TRIMMED BACK
	CAMN	PDA,CDLSAV		;IS THIS THE PARENT ???
	HRRZS	LLFGR			;USE THIS AS A FLAG
	HRRZ	SIN,PD.LLW(PDA)		;POINTER AT LVI INFO
NXTEN:	SKIPN	EN,(SIN)		;A ZERO SAYS
	JRST	EOPD			;WE ARE AT END OF LOC VAR INF
TPGET:	LDB	A,[POINT 4,EN,3]	;TYPE FIELD
	CAIN	A,17			;IGNORE END OOF BK ENTRIES
	AOJA	SIN,NXTEN
	JUMPL	LLFGR,DOIT		;IF NOT AT RIGHT DL, ZAP EM ALL
	LDB	B,[POINT =9,EN,=12]	;LL FIELD
	CAMG	B,LLFGR			;IF LEX LEV IS LOW ENOUGH
	AOJA	SIN,NXTEN		;LET HIM LIVE -- VERY INEFFICIENT CODE
DOIT:	PUSHJ	P,@LVIDAC(A)		;CALL APPROPRIATE ROUTINE
	AOJA	SIN,NXTEN
EOPD:	JUMPL	LLFGR,EOPD.1		;RETURN TEST
	MOVE 	USER,GOGTAB		;
	JRST	@STKURT(USER)
EOPD.1:	HRRZ	SIN,PD.DLW(PDA)		;NOW HAVE TO CLEAR OUT SET FORMALS
	HRRZ	B,PD.NPW(PDA)		;#ARITH +1
	MOVE	C,RF			;F REG
	SUBI	C,1(B)			;C← PTR 1 BEFORE 1'ST ARITH PARM
PARLP:	SOJLE	B,ADJSKS		;COUNT DOWN # ARGS
	AOS	C			;POINT AT NEXT
	MOVE	B,(SIN)			;TYPE CODE
	TLC	B,SETYPE⊗5		;VALUE SET MUST BE RELEASED
	TLNN	B,REFB!ITEMB!PROCB	;THESE ARE NOT RELEASED
	TLNE	B,MSK6BT		;CHECK THE SET CODE
	AOJA	SIN,PARLP		;IF NOT VALUE SET, NO PROBLEMS
	MOVEI	EN,(C)			;EN←← PTR TO SET
	PUSHJ	P,@LVIDAC+3		;CALL SET RELEASER
	AOJA	SIN,PARLP		;GO ON TO NEXT
ADJSKS:	HRRZ	RF,(RF)			;BACK A DYNAMIC LINK
	JRST	PLOOP			;
BEND STKUWD
HERE (ARRINFO)
BEGIN ARRINFO
	MOVE	A,-2(P)	;ARRAY ADDRESS
	SKIPGE	-2(A)	;STRING ARRAY?
	 SUBI	 A,1		; YES, BACK UP FOR IT
	SKIPGE	TEMP,-1(P)	;CONTROL PARAMETER
	 JRST	 [HLRE A,-1(A) ;WANTS NUMBER OF DIMENSIONS
		   JRST RSINFO]
	JUMPE	TEMP,[HRRZ A,-1(A) ;WANTS TOTAL SIZE
			JRST RSINFO]
	ROT	TEMP,-1		;SAVE LOW ORDER BIT AS SIGN
	MOVNI	LPSA,3		;GET DISPLACEMENT INTO ARRAY TABLE
	IMULI	LPSA,(TEMP)
	SKIPGE	TEMP		;WANT UPPER OR LOWER BOUND
	SUBI	LPSA,4
	HRLI	A,LPSA
	MOVE	A,@A		;GET THE REQD BOUND
RSINFO:	
	SUB	P,X33
	JRST	@3(P)
BEND ARRINFO
HERE (ARRBLT) 
BEGIN ARRBLT
	SOSGE	LPSA,-1(P)		;GET LENGTH, SUBTRACT 1
	  JRST	BLTRET			;LEQ 0, DONT BLT
	HRRZ	TEMP,-3(P)
	HRL	TEMP,-2(P)
	ADDI	LPSA,(TEMP)
	BLT	TEMP,(LPSA)
BLTRET:	SUB	P,X44
	JRST	@4(P)
BEND  ARRBLT
HERE (ARRTRAN)
BEGIN ARRTRAN
	HRRZ	TEMP,-2(P)		;DEST ARRAY ADDR
	HRRZ	LPSA,-1(P)		;SOURCE ARRAY ADDR
	SKIPL	-2(TEMP)		;STRING ARRAY?
	 JRST	 NSTR			; NO
	SUBI	TEMP,1
	SUBI	LPSA,1
NSTR:	HRL	TEMP,LPSA		;BLT WORD
	HRRZ	LPSA,-1(LPSA)		;SOURCE SIZE
	HRRZ	USER,-1(TEMP)
	CAMLE	LPSA,USER
	 HRRZ	 LPSA,USER
	ADDI	LPSA,-1(TEMP)		;TERMINATION WORD
	BLT	TEMP,(LPSA)
	SUB	P,X33
	JRST	@3(P)
BEND ARRTRAN
HERE(ARRCLR)
BEGIN ARRCLR
	MOVE	USER,-1(P)		;VALUE TO PUT
	MOVE	TEMP,-2(P)		;GET ADDRESS OF ARRAY
	SKIPL	-2(TEMP)		;CHECK STRING ARRAY
	JRST	NOSACL
	SUBI	TEMP,1			;A STRING ARRAY STARTS EARLIER
	CAIE	USER,0			;
	ERR	<YOU CANNOT CLEAR STRING ARRAYS TO OTHER THAN NULL>;
NOSACL:	HRLI	LPSA,(TEMP)		;PREPARE FOR BLT
	HRRI	LPSA,1(TEMP)
	MOVEM	USER,(TEMP)
	HRRZ	USER,-1(TEMP)		;GET NUMBER OF WORDS IN ARRAY
	ADDI	TEMP,-1(USER)		;NUMBER OF WORDS TO MOVE IN BLT
	BLT	LPSA,(TEMP)		;DO A BLT
	SUB	P,X33
	JRST	@3(P)			;RETURN
BEND ARRCLR
ENDCOM(ARY)